home *** CD-ROM | disk | FTP | other *** search
/ Chip 2004 July / Chip Temmuz 2004.iso / program / antispam / RazorAgent_SDK / razor-agents-sdk-2.03.exe / URI-1.19 / t / old-base.t < prev    next >
Encoding:
Text File  |  2001-09-06  |  33.4 KB  |  1,019 lines
  1. #!/local/bin/perl -w
  2.  
  3. use URI::URL qw(url);
  4. use URI::Escape qw(uri_escape uri_unescape);
  5.  
  6. # _expect()
  7. #
  8. # Handy low-level object method tester which we insert as a method
  9. # in the URI::URL class
  10. #
  11. sub URI::URL::_expect {
  12.     my($self, $method, $expect, @args) = @_;
  13.     my $result = $self->$method(@args);
  14.     $expect = 'UNDEF' unless defined $expect;
  15.     $result = 'UNDEF' unless defined $result;
  16.     return 1 if $expect eq $result;
  17.     warn "'$self'->$method(@args) = '$result' " .
  18.         "(expected '$expect')\n";
  19.     $self->print_on('STDERR');
  20.     die "Test Failed";
  21. }
  22.  
  23. package main;
  24.  
  25. # Must ensure that there is no relative paths in @INC because we will
  26. # chdir in the newlocal tests.
  27. unless ($^O eq "MacOS") {
  28. chomp($pwd = ($^O =~ /mswin32/i ? `cd` : $^O eq 'VMS' ? `show default` : `pwd`));
  29. if ($^O eq 'VMS') {
  30.     $pwd =~ s#^\s+##;
  31.     $pwd = VMS::Filespec::unixpath($pwd);
  32.     $pwd =~ s#/$##;
  33. }
  34. for (@INC) {
  35.     my $x = $_;
  36.     $x = VMS::Filespec::unixpath($x) if $^O eq 'VMS';
  37.     next if $x =~ m|^/| or $^O =~ /os2|mswin32/i and $x =~ m|^\w:[\\/]|;
  38.     print "Turn lib path $x into $pwd/$x\n";
  39.     $_ = "$pwd/$x";
  40.  
  41. }
  42. }
  43.  
  44. $| = 1;
  45.  
  46. print "1..8\n";  # for Test::Harness
  47.  
  48. # Do basic tests first.
  49. # Dies if an error has been detected, prints "ok" otherwise.
  50.  
  51. print "Self tests for URI::URL version $URI::URL::VERSION...\n";
  52.  
  53. eval { scheme_parse_test(); };
  54. print "not " if $@;
  55. print "ok 1\n";
  56.  
  57. eval { parts_test(); };
  58. print "not " if $@;
  59. print "ok 2\n";
  60.  
  61. eval { escape_test(); };
  62. print "not " if $@;
  63. print "ok 3\n";
  64.  
  65. eval { newlocal_test(); };
  66. print "not " if $@;
  67. print "ok 4\n";
  68.  
  69. eval { absolute_test(); };
  70. print "not " if $@;
  71. print "ok 5\n";
  72.  
  73. eval { eq_test(); };
  74. print "not " if $@;
  75. print "ok 6\n";
  76.  
  77. # Let's test making our own things
  78. URI::URL::strict(0);
  79. # This should work after URI::URL::strict(0)
  80. $url = new URI::URL "x-myscheme:something";
  81. # Since no implementor is registered for 'x-myscheme' then it will
  82. # be handled by the URI::URL::_generic class
  83. $url->_expect('as_string' => 'x-myscheme:something');
  84. $url->_expect('path' => 'something');
  85. URI::URL::strict(1);
  86.  
  87. =comment
  88.  
  89. # Let's try to make our URL subclass
  90. {
  91.     package MyURL;
  92.     @ISA = URI::URL::implementor();
  93.  
  94.     sub _parse {
  95.     my($self, $init) = @_;
  96.     $self->URI::URL::_generic::_parse($init, qw(netloc path));
  97.     }
  98.  
  99.     sub foo {
  100.     my $self = shift;
  101.     print ref($self)."->foo called for $self\n";
  102.     }
  103. }
  104. # Let's say that it implements the 'x-a+b.c' scheme (alias 'x-foo')
  105. URI::URL::implementor('x-a+b.c', 'MyURL');
  106. URI::URL::implementor('x-foo', 'MyURL');
  107.  
  108. # Now we are ready to try our new URL scheme
  109. $url = new URI::URL 'x-a+b.c://foo/bar;a?b';
  110. $url->_expect('as_string', 'x-a+b.c://foo/bar;a?b');
  111. $url->_expect('path', '/bar;a?b');
  112. $url->foo;
  113. $newurl = new URI::URL 'xxx', $url;
  114. $newurl->foo;
  115. $url = new URI::URL 'yyy', 'x-foo:';
  116. $url->foo;
  117.  
  118. =cut
  119.  
  120. print "ok 7\n";
  121.  
  122. # Test the new wash&go constructor
  123. print "not " if url("../foo.html", "http://www.sn.no/a/b")->abs->as_string
  124.         ne 'http://www.sn.no/foo.html';
  125. print "ok 8\n";
  126.  
  127. print "URI::URL version $URI::URL::VERSION ok\n";
  128.  
  129. exit 0;
  130.  
  131.  
  132.  
  133.  
  134. #####################################################################
  135. #
  136. # scheme_parse_test()
  137. #
  138. # test parsing and retrieval methods
  139.  
  140. sub scheme_parse_test {
  141.  
  142.     print "scheme_parse_test:\n";
  143.  
  144.     $tests = {
  145.     'hTTp://web1.net/a/b/c/welcome#intro'
  146.     => {    'scheme'=>'http', 'host'=>'web1.net', 'port'=>80,
  147.         'path'=>'/a/b/c/welcome', 'frag'=>'intro','query'=>undef,
  148.         'epath'=>'/a/b/c/welcome', 'equery'=>undef,
  149.         'params'=>undef, 'eparams'=>undef,
  150.         'as_string'=>'http://web1.net/a/b/c/welcome#intro',
  151.         'full_path' => '/a/b/c/welcome' },
  152.  
  153.     'http://web:1/a?query+text'
  154.     => {    'scheme'=>'http', 'host'=>'web', 'port'=>1,
  155.         'path'=>'/a', 'frag'=>undef, 'query'=>'query+text' },
  156.  
  157.     'http://web.net/'
  158.     => {    'scheme'=>'http', 'host'=>'web.net', 'port'=>80,
  159.         'path'=>'/', 'frag'=>undef, 'query'=>undef,
  160.         'full_path' => '/',
  161.         'as_string' => 'http://web.net/' },
  162.  
  163.     'http://web.net'
  164.     => {    'scheme'=>'http', 'host'=>'web.net', 'port'=>80,
  165.         'path'=>'/', 'frag'=>undef, 'query'=>undef,
  166.         'full_path' => '/',
  167.         'as_string' => 'http://web.net/' },
  168.  
  169.     'http:0'
  170.      => {   'scheme'=>'http', 'path'=>'0', 'query'=>undef,
  171.         'as_string'=>'http:0', 'full_path'=>'0', },
  172.  
  173.     'http:/0?0'
  174.      => {   'scheme'=>'http', 'path'=>'/0', 'query'=>'0',
  175.         'as_string'=>'http:/0?0', 'full_path'=>'/0?0', },
  176.  
  177.     'http://0:0/0/0;0?0#0'
  178.      => {   'scheme'=>'http', 'host'=>'0', 'port'=>'0',
  179.         'path' => '/0/0', 'query'=>'0', 'params'=>'0',
  180.         'netloc'=>'0:0',
  181.         'frag'=>0, 'as_string'=>'http://0:0/0/0;0?0#0' },
  182.  
  183.     'ftp://0%3A:%40@h:0/0?0'
  184.     =>  {   'scheme'=>'ftp', 'user'=>'0:', 'password'=>'@',
  185.         'host'=>'h', 'port'=>'0', 'path'=>'/0?0',
  186.         'query'=>'0', params=>undef,
  187.         'netloc'=>'0%3A:%40@h:0',
  188.         'as_string'=>'ftp://0%3A:%40@h:0/0?0' },
  189.  
  190.     'ftp://usr:pswd@web:1234/a/b;type=i'
  191.     => {    'host'=>'web', 'port'=>1234, 'path'=>'/a/b',
  192.         'user'=>'usr', 'password'=>'pswd',
  193.         'params'=>'type=i',
  194.         'as_string'=>'ftp://usr:pswd@web:1234/a/b;type=i' },
  195.  
  196.     'ftp://host/a/b'
  197.     => {    'host'=>'host', 'port'=>21, 'path'=>'/a/b',
  198.         'user'=>'anonymous',
  199.         'as_string'=>'ftp://host/a/b' },
  200.  
  201.     'file://host/fseg/fs?g/fseg'
  202.     # don't escape ? for file: scheme
  203.     => {    'host'=>'host', 'path'=>'/fseg/fs?g/fseg',
  204.         'as_string'=>'file://host/fseg/fs?g/fseg' },
  205.  
  206.     'gopher://host'
  207.     => {     'gtype'=>'1', 'as_string' => 'gopher://host', },
  208.  
  209.     'gopher://host/'
  210.     => {     'gtype'=>'1', 'as_string' => 'gopher://host/', },
  211.  
  212.     'gopher://gopher/2a_selector'
  213.     => {    'gtype'=>'2', 'selector'=>'a_selector',
  214.         'as_string' => 'gopher://gopher/2a_selector', },
  215.  
  216.     'mailto:libwww-perl@ics.uci.edu'
  217.     => {    'address'       => 'libwww-perl@ics.uci.edu',
  218.         'encoded822addr'=> 'libwww-perl@ics.uci.edu',
  219. #        'user'          => 'libwww-perl',
  220. #        'host'          => 'ics.uci.edu',
  221.         'as_string'     => 'mailto:libwww-perl@ics.uci.edu', },
  222.  
  223.     'news:*'
  224.     => {    'groupart'=>'*', 'group'=>'*', as_string=>'news:*' },
  225.     'news:comp.lang.perl'
  226.     => {    'group'=>'comp.lang.perl' },
  227.     'news:perl-faq/module-list-1-794455075@ig.co.uk'
  228.     => {    'article'=>
  229.             'perl-faq/module-list-1-794455075@ig.co.uk' },
  230.  
  231.     'nntp://news.com/comp.lang.perl/42'
  232.     => {    'group'=>'comp.lang.perl', }, #'digits'=>42 },
  233.  
  234.     'telnet://usr:pswd@web:12345/'
  235.     => {    'user'=>'usr', 'password'=>'pswd', 'host'=>'web' },
  236.     'rlogin://aas@a.sn.no'
  237.     => {    'user'=>'aas', 'host'=>'a.sn.no' },
  238. #    'tn3270://aas@ibm'
  239. #    => {    'user'=>'aas', 'host'=>'ibm',
  240. #        'as_string'=>'tn3270://aas@ibm/'},
  241.  
  242. #    'wais://web.net/db'
  243. #    => { 'database'=>'db' },
  244. #    'wais://web.net/db?query'
  245. #    => { 'database'=>'db', 'query'=>'query' },
  246. #    'wais://usr:pswd@web.net/db/wt/wp'
  247. #    => {    'database'=>'db', 'wtype'=>'wt', 'wpath'=>'wp',
  248. #        'password'=>'pswd' },
  249.     };
  250.  
  251.     foreach $url_str (sort keys %$tests ){
  252.     print "Testing '$url_str'\n";
  253.     my $url = new URI::URL $url_str;
  254.     my $tests = $tests->{$url_str};
  255.     while( ($method, $exp) = each %$tests ){
  256.         $exp = 'UNDEF' unless defined $exp;
  257.         $url->_expect($method, $exp);
  258.     }
  259.     }
  260. }
  261.  
  262.  
  263. #####################################################################
  264. #
  265. # parts_test()          (calls netloc_test test)
  266. #
  267. # Test individual component part access functions
  268. #
  269. sub parts_test {
  270.     print "parts_test:\n";
  271.  
  272.     # test storage part access/edit methods (netloc, user, password,
  273.     # host and port are tested by &netloc_test)
  274.  
  275.     $url = new URI::URL 'file://web/orig/path';
  276.     $url->scheme('http');
  277.     $url->path('1info');
  278.     $url->query('key words');
  279.     $url->frag('this');
  280.     $url->_expect('as_string' => 'http://web/1info?key%20words#this');
  281.  
  282.     $url->epath('%2f/%2f');
  283.     $url->equery('a=%26');
  284.     $url->_expect('full_path' => '/%2f/%2f?a=%26');
  285.  
  286.     # At this point it should be impossible to access the members path()
  287.     # and query() without complaints.
  288.     eval { my $p = $url->path; print "Path is $p\n"; };
  289.     die "Path exception failed" unless $@;
  290.     eval { my $p = $url->query; print "Query is $p\n"; };
  291.     die "Query exception failed" unless $@;
  292.  
  293.     # but we should still be able to set it 
  294.     $url->path("howdy");
  295.     $url->_expect('as_string' => 'http://web/howdy?a=%26#this');
  296.  
  297.     # Test the path_components function
  298.     $url = new URI::URL 'file:%2f/%2f';
  299.     my $p;
  300.     $p = join('-', $url->path_components);
  301.     die "\$url->path_components returns '$p', expected '/-/'"
  302.       unless $p eq "/-/";
  303.     $url->host("localhost");
  304.     $p = join('-', $url->path_components);
  305.     die "\$url->path_components returns '$p', expected '-/-/'"
  306.       unless $p eq "-/-/";
  307.     $url->epath("/foo/bar/");
  308.     $p = join('-', $url->path_components);
  309.     die "\$url->path_components returns '$p', expected '-foo-bar-'"
  310.       unless $p eq "-foo-bar-";
  311.     $url->path_components("", "/etc", "\0", "..", "°se", "");
  312.     $url->_expect('full_path' => '/%2Fetc/%00/../%F8se/');
  313.  
  314.     # Setting undef
  315.     $url = new URI::URL 'http://web/p;p?q#f';
  316.     $url->epath(undef);
  317.     $url->equery(undef);
  318.     $url->eparams(undef);
  319.     $url->frag(undef);
  320.     $url->_expect('as_string' => 'http://web');
  321.  
  322.     # Test http query access methods
  323.     $url->keywords('dog');
  324.     $url->_expect('as_string' => 'http://web?dog');
  325.     $url->keywords(qw(dog bones));
  326.     $url->_expect('as_string' => 'http://web?dog+bones');
  327.     $url->keywords(0,0);
  328.     $url->_expect('as_string' => 'http://web?0+0');
  329.     $url->keywords('dog', 'bones', '#+=');
  330.     $url->_expect('as_string' => 'http://web?dog+bones+%23%2B%3D');
  331.     $a = join(":", $url->keywords);
  332.     die "\$url->keywords did not work (returned '$a')" unless $a eq 'dog:bones:#+=';
  333.     # calling query_form is an error
  334. #    eval { my $foo = $url->query_form; };
  335. #    die "\$url->query_form should croak since query contains keywords not a form."
  336. #      unless $@;
  337.  
  338.     $url->query_form(a => 'foo', b => 'bar');
  339.     $url->_expect('as_string' => 'http://web?a=foo&b=bar');
  340.     my %a = $url->query_form;
  341.     die "\$url->query_form did not work"
  342.       unless $a{a} eq 'foo' && $a{b} eq 'bar';
  343.  
  344.     $url->query_form(a => undef, a => 'foo', '&=' => '&=+');
  345.     $url->_expect('as_string' => 'http://web?a=&a=foo&%26%3D=%26%3D%2B');
  346.  
  347.     my @a = $url->query_form;
  348.     die "Wrong length" unless @a == 6;
  349.     die "Bad keys from query_form"
  350.       unless $a[0] eq 'a' && $a[2] eq 'a' && $a[4] eq '&=';
  351.     die "Bad values from query_form"
  352.       unless $a[1] eq '' && $a[3] eq 'foo' && $a[5] eq '&=+';
  353.  
  354.     # calling keywords is an error
  355. #    eval { my $foo = $url->keywords; };
  356. #    die "\$url->keywords should croak when query is a form"
  357. #      unless $@;
  358.     # Try this odd one
  359.     $url->equery('&=&=b&a=&a&a=b=c&&a=b');
  360.     @a = $url->query_form;
  361.     #print join(":", @a), "\n";
  362.     die "Wrong length" unless @a == 16;
  363.     die "Wrong sequence" unless $a[4]  eq ""  && $a[5]  eq "b" &&
  364.                                 $a[10] eq "a" && $a[11] eq "b=c";
  365.  
  366.     # Try array ref values in the key value pairs
  367.     $url->query_form(a => ['foo', 'bar'], b => 'foo', c => ['bar', 'foo']);
  368.     $url->_expect('as_string', 'http://web?a=foo&a=bar&b=foo&c=bar&c=foo');
  369.  
  370.  
  371.     netloc_test();
  372.     port_test();
  373.  
  374.     $url->query(undef);
  375.     $url->_expect('query', undef);
  376.  
  377.     $url = new URI::URL 'gopher://gopher/';
  378.     $url->port(33);
  379.     $url->gtype("3");
  380.     $url->selector("S");
  381.     $url->search("query");
  382.     $url->_expect('as_string', 'gopher://gopher:33/3S%09query');
  383.  
  384.     $url->epath("45%09a");
  385.     $url->_expect('gtype' => '4');
  386.     $url->_expect('selector' => '5');
  387.     $url->_expect('search' => 'a');
  388.     $url->_expect('string' => undef);
  389.     $url->_expect('path' => "/45\ta");
  390. #    $url->path("00\t%09gisle");
  391. #    $url->_expect('search', '%09gisle');
  392.  
  393.     # Let's test som other URL schemes
  394.     $url = new URI::URL 'news:';
  395.     $url->group("comp.lang.perl.misc");
  396.     $url->_expect('as_string' => 'news:comp.lang.perl.misc');
  397.     $url->article('<1234@a.sn.no>');
  398.     $url->_expect('as_string' => 'news:1234@a.sn.no'); # "<" and ">" are gone
  399.     # This one should be illegal
  400.     eval { $url->article("no.perl"); };
  401.     die "This one should really complain" unless $@;
  402.  
  403. #    $url = new URI::URL 'mailto:';
  404. #    $url->user("aas");
  405. #    $url->host("a.sn.no");
  406. #    $url->_expect("as_string" => 'mailto:aas@a.sn.no');
  407. #    $url->address('foo@bar');
  408. #    $url->_expect("host" => 'bar');
  409. #    $url->_expect("user" => 'foo');
  410.  
  411. #    $url = new URI::URL 'wais://host/database/wt/wpath';
  412. #    $url->database('foo');
  413. #    $url->_expect('as_string' => 'wais://host/foo/wt/wpath');
  414. #    $url->wtype('bar');
  415. #    $url->_expect('as_string' => 'wais://host/foo/bar/wpath');
  416.  
  417.     # Test crack method for various URLs
  418.     my(@crack, $crack);
  419.     @crack = URI::URL->new("http://host/path;param?query#frag")->crack;
  420.     die "Cracked result should be 9 elements" unless @crack == 9;
  421.     $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
  422.     print "Cracked result: $crack\n";
  423.     die "Bad crack result" unless
  424.       $crack eq "http*UNDEF*UNDEF*host*80*/path*param*query*frag";
  425.  
  426.     @crack = URI::URL->new("foo/bar", "ftp://aas\@ftp.sn.no/")->crack;
  427.     die "Cracked result should be 9 elements" unless @crack == 9;
  428.     $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
  429.     print "Cracked result: $crack\n";
  430. #    die "Bad crack result" unless
  431. #      $crack eq "ftp*UNDEF*UNDEF*UNDEF*21*foo/bar*UNDEF*UNDEF*UNDEF";
  432.  
  433.     @crack = URI::URL->new('ftp://u:p@host/q?path')->crack;
  434.     die "Cracked result should be 9 elements" unless @crack == 9;
  435.     $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
  436.     print "Cracked result: $crack\n";
  437.     die "Bad crack result" unless
  438.       $crack eq "ftp*u*p*host*21*/q?path*UNDEF*path*UNDEF";
  439.  
  440.     @crack = URI::URL->new("ftp://ftp.sn.no/pub")->crack;    # Test anon ftp
  441.     die "Cracked result should be 9 elements" unless @crack == 9;
  442.     die "No passwd in anonymous crack" unless $crack[2];
  443.     $crack[2] = 'passwd';  # easier to test when we know what it is
  444.     $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
  445.     print "Cracked result: $crack\n";
  446.     die "Bad crack result" unless
  447.       $crack eq "ftp*anonymous*passwd*ftp.sn.no*21*/pub*UNDEF*UNDEF*UNDEF";
  448.  
  449.     @crack = URI::URL->new('mailto:aas@sn.no')->crack;
  450.     die "Cracked result should be 9 elements" unless @crack == 9;
  451.     $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
  452.     print "Cracked result: $crack\n";
  453. #    die "Bad crack result" unless
  454. #      $crack eq "mailto*aas*UNDEF*sn.no*UNDEF*aas\@sn.no*UNDEF*UNDEF*UNDEF";
  455.  
  456.     @crack = URI::URL->new('news:comp.lang.perl.misc')->crack;
  457.     die "Cracked result should be 9 elements" unless @crack == 9;
  458.     $crack = join("*", map { defined($_) ? $_ : "UNDEF" } @crack);
  459.     print "Cracked result: $crack\n";
  460.     die "Bad crack result" unless
  461.       $crack eq "news*UNDEF*UNDEF*UNDEF*119*comp.lang.perl.misc*UNDEF*UNDEF*UNDEF";
  462. }
  463.  
  464. #
  465. # netloc_test()
  466. #
  467. # Test automatic netloc synchronisation
  468. #
  469. sub netloc_test {
  470.     print "netloc_test:\n";
  471.  
  472.     my $url = new URI::URL 'ftp://anonymous:p%61ss@hσst:12345';
  473.     $url->_expect('user', 'anonymous');
  474.     $url->_expect('password', 'pass');
  475.     $url->_expect('host', 'hσst');
  476.     $url->_expect('port', 12345);
  477.     # Can't really know how netloc is represented since it is partially escaped
  478.     #$url->_expect('netloc', 'anonymous:pass@hst:12345');
  479.     $url->_expect('as_string' => 'ftp://anonymous:p%61ss@h%E5st:12345');
  480.  
  481.     # The '0' is sometimes tricky to get right
  482.     $url->user(0);
  483.     $url->password(0);
  484.     $url->host(0);
  485.     $url->port(0);
  486.     $url->_expect('netloc' => '0:0@0:0');
  487.     $url->host(undef);
  488.     $url->_expect('netloc' => '0:0@:0');
  489.     $url->host('h');
  490.     $url->user(undef);
  491.     $url->_expect('netloc' => ':0@h:0');
  492.     $url->user('');
  493.     $url->_expect('netloc' => ':0@h:0');
  494.     $url->password('');
  495.     $url->_expect('netloc' => ':@h:0');
  496.     $url->user('foo');
  497.     $url->_expect('netloc' => 'foo:@h:0');
  498.  
  499.     # Let's try a simple one
  500.     $url->user('nemo');
  501.     $url->password('p2');
  502.     $url->host('hst2');
  503.     $url->port(2);
  504.     $url->_expect('netloc' => 'nemo:p2@hst2:2');
  505.  
  506.     $url->user(undef);
  507.     $url->password(undef);
  508.     $url->port(undef);
  509.     $url->_expect('netloc' => 'hst2');
  510.     $url->_expect('port' => '21');  # the default ftp port
  511.  
  512.     $url->port(21);
  513.     $url->_expect('netloc' => 'hst2:21');
  514.  
  515.     # Let's try some reserved chars
  516.     $url->user("@");
  517.     $url->password(":-#-;-/-?");
  518.     $url->_expect('as_string' => 'ftp://%40::-%23-;-%2F-%3F@hst2:21');
  519.  
  520. }
  521.  
  522. #
  523. # port_test()
  524. #
  525. # Test port behaviour
  526. #
  527. sub port_test {
  528.     print "port_test:\n";
  529.  
  530.     $url = URI::URL->new('http://foo/root/dir/');
  531.     my $port = $url->port;
  532.     die "Port undefined" unless defined $port;
  533.     die "Wrong port $port" unless $port == 80;
  534.     die "Wrong string" unless $url->as_string eq
  535.     'http://foo/root/dir/';
  536.  
  537.     $url->port(8001);
  538.     $port = $url->port;
  539.     die "Port undefined" unless defined $port;
  540.     die "Wrong port $port" unless $port == 8001;
  541.     die "Wrong string" unless $url->as_string eq
  542.     'http://foo:8001/root/dir/';
  543.  
  544.     $url->port(80);
  545.     $port = $url->port;
  546.     die "Port undefined" unless defined $port;
  547.     die "Wrong port $port" unless $port == 80;
  548.     die "Wrong string" unless $url->canonical->as_string eq
  549.     'http://foo/root/dir/';
  550.  
  551.     $url->port(8001);
  552.     $url->port(undef);
  553.     $port = $url->port;
  554.     die "Port undefined" unless defined $port;
  555.     die "Wrong port $port" unless $port == 80;
  556.     die "Wrong string" unless $url->as_string eq
  557.     'http://foo/root/dir/';
  558. }
  559.  
  560.  
  561. #####################################################################
  562. #
  563. # escape_test()
  564. #
  565. # escaping functions
  566.  
  567. sub escape_test {
  568.     print "escape_test:\n";
  569.  
  570.     # supply escaped URL
  571.     $url = new URI::URL 'http://web/this%20has%20spaces';
  572.     # check component is unescaped
  573.     $url->_expect('path', '/this has spaces');
  574.  
  575.     # modify the unescaped form
  576.     $url->path('this ALSO has spaces');
  577.     # check whole url is escaped
  578.     $url->_expect('as_string',
  579.           'http://web/this%20ALSO%20has%20spaces');
  580.  
  581.     $url = new URI::URL uri_escape('http://web/try %?#" those');
  582.     $url->_expect('as_string',
  583.           'http%3A%2F%2Fweb%2Ftry%20%25%3F%23%22%20those');
  584.  
  585.     my $all = pack('C*',0..255);
  586.     my $esc = uri_escape($all);
  587.     my $new = uri_unescape($esc);
  588.     die "uri_escape->uri_unescape mismatch" unless $all eq $new;
  589.  
  590.     $url->path($all);
  591.     $url->_expect('full_path' => q(%00%01%02%03%04%05%06%07%08%09%0A%0B%0C%0D%0E%0F%10%11%12%13%14%15%16%17%18%19%1A%1B%1C%1D%1E%1F%20!%22%23$%&'()*+,-./0123456789:;%3C=%3E%3F@ABCDEFGHIJKLMNOPQRSTUVWXYZ[%5C]%5E_%60abcdefghijklmnopqrstuvwxyz%7B%7C%7D~%7F%80%81%82%83%84%85%86%87%88%89%8A%8B%8C%8D%8E%8F%90%91%92%93%94%95%96%97%98%99%9A%9B%9C%9D%9E%9F%A0%A1%A2%A3%A4%A5%A6%A7%A8%A9%AA%AB%AC%AD%AE%AF%B0%B1%B2%B3%B4%B5%B6%B7%B8%B9%BA%BB%BC%BD%BE%BF%C0%C1%C2%C3%C4%C5%C6%C7%C8%C9%CA%CB%CC%CD%CE%CF%D0%D1%D2%D3%D4%D5%D6%D7%D8%D9%DA%DB%DC%DD%DE%DF%E0%E1%E2%E3%E4%E5%E6%E7%E8%E9%EA%EB%EC%ED%EE%EF%F0%F1%F2%F3%F4%F5%F6%F7%F8%F9%FA%FB%FC%FD%FE%FF));
  592.  
  593.     # test escaping uses uppercase (preferred by rfc1837)
  594.     $url = new URI::URL 'file://h/';
  595.     $url->path(chr(0x7F));
  596.     $url->_expect('as_string', 'file://h/%7F');
  597.  
  598.     return;
  599.     # reserved characters differ per scheme
  600.  
  601.     ## XXX is this '?' allowed to be unescaped
  602.     $url = new URI::URL 'file://h/test?ing';
  603.     $url->_expect('path', '/test?ing');
  604.  
  605.     $url = new URI::URL 'file://h/';
  606.     $url->epath('question?mark');
  607.     $url->_expect('as_string', 'file://h/question?mark');
  608.     # XXX Why should this be any different???
  609.     #     Perhaps we should not expect too much :-)
  610.     $url->path('question?mark');
  611.     $url->_expect('as_string', 'file://h/question%3Fmark');
  612.  
  613.     # See what happens when set different elements to this ugly sting
  614.     my $reserved = ';/?:@&=#%';
  615.     $url->path($reserved . "foo");
  616.     $url->_expect('as_string', 'file://h/%3B/%3F%3A%40%26%3D%23%25foo');
  617.  
  618.     $url->scheme('http');
  619.     $url->path('');
  620.     $url->_expect('as_string', 'http://h/');
  621.     $url->query($reserved);
  622.     $url->params($reserved);
  623.     $url->frag($reserved);
  624.     $url->_expect('as_string', 'http://h/;%3B%2F%3F%3A%40&=%23%25?%3B%2F%3F%3A%40&=%23%25#;/?:@&=#%');
  625.  
  626.     $str = $url->as_string;
  627.     $url = new URI::URL $str;
  628.     die "URL changed" if $str ne $url->as_string;
  629.  
  630.     $url = new URI::URL 'ftp:foo';
  631.     $url->user($reserved);
  632.     $url->host($reserved);
  633.     $url->_expect('as_string', 'ftp://%3B%2F%3F%3A%40%26%3D%23%25@%3B%2F%3F%3A%40%26%3D%23%25/foo');
  634.  
  635. }
  636.  
  637.  
  638. #####################################################################
  639. #
  640. # newlocal_test()
  641. #
  642.  
  643. sub newlocal_test {
  644.     return 1 if $^O eq "MacOS";
  645.     
  646.     print "newlocal_test:\n";
  647.     my $isMSWin32 = ($^O =~ /MSWin32/i);
  648.     my $pwd = ($isMSWin32 ? 'cd' :
  649.           ($^O eq 'qnx' ? '/usr/bin/fullpath -t' :
  650.               ($^O eq 'VMS' ? 'show default' :
  651.               (-e '/bin/pwd' ? '/bin/pwd' : 'pwd'))));
  652.     my $tmpdir = ($^O eq 'MSWin32' ? $ENV{TEMP} : '/tmp');
  653.     if ( $^O eq 'qnx' ) {
  654.     $tmpdir = `/usr/bin/fullpath -t $tmpdir`;
  655.     chomp $tmpdir;
  656.     }
  657.     $tmpdir = '/sys$scratch' if $^O eq 'VMS';
  658.     $tmpdir =~ tr|\\|/|;
  659.  
  660.     my $savedir = `$pwd`;     # we don't use Cwd.pm because we want to check
  661.                   # that it get require'd correctly by URL.pm
  662.     chomp $savedir;
  663.     if ($^O eq 'VMS') {
  664.         $savedir =~ s#^\s+##;
  665.         $savedir = VMS::Filespec::unixpath($savedir);
  666.         $savedir =~ s#/$##;
  667.     }
  668.  
  669.     # cwd
  670.     chdir($tmpdir) or die $!;
  671.     my $dir = `$pwd`; $dir =~ tr|\\|/|;
  672.     chomp $dir;
  673.     if ($^O eq 'VMS') {
  674.         $dir =~ s#^\s+##;
  675.         $dir = VMS::Filespec::unixpath($dir);
  676.         $dir =~ s#/$##;
  677.     }
  678.     $dir = uri_escape($dir, ':');
  679.     $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32;
  680.     $url = newlocal URI::URL;
  681.     my $ss = $isMSWin32 ? '//' : '';
  682.     $url->_expect('as_string', URI::URL->new("file:$ss$dir/")->as_string);
  683.  
  684.     print "Local directory is ". $url->local_path . "\n";
  685.  
  686.     if ($^O ne 'VMS') {
  687.     # absolute dir
  688.     chdir('/') or die $!;
  689.     $url = newlocal URI::URL '/usr/';
  690.     $url->_expect('as_string', 'file:/usr/');
  691.  
  692.     # absolute file
  693.     $url = newlocal URI::URL '/vmunix';
  694.     $url->_expect('as_string', 'file:/vmunix');
  695.     }
  696.  
  697.     # relative file
  698.     chdir($tmpdir) or die $!;
  699.     $dir = `$pwd`; $dir =~ tr|\\|/|;
  700.     chomp $dir;
  701.     if ($^O eq 'VMS') {
  702.         $dir =~ s#^\s+##;
  703.         $dir = VMS::Filespec::unixpath($dir);
  704.         $dir =~ s#/$##;
  705.     }
  706.     $dir = uri_escape($dir, ':');
  707.     $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32;
  708.     $url = newlocal URI::URL 'foo';
  709.     $url->_expect('as_string', "file:$ss$dir/foo");
  710.  
  711.     # relative dir
  712.     chdir($tmpdir) or die $!;
  713.     $dir = `$pwd`; $dir =~ tr|\\|/|;
  714.     chomp $dir;
  715.     if ($^O eq 'VMS') {
  716.         $dir =~ s#^\s+##;
  717.         $dir = VMS::Filespec::unixpath($dir);
  718.         $dir =~ s#/$##;
  719.     }
  720.     $dir = uri_escape($dir, ':');
  721.     $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32;
  722.     $url = newlocal URI::URL 'bar/';
  723.     $url->_expect('as_string', "file:$ss$dir/bar/");
  724.  
  725.     # 0
  726.     if ($^O ne 'VMS') {
  727.     chdir('/') or die $!;
  728.     $dir = `$pwd`; $dir =~ tr|\\|/|;
  729.         chomp $dir;
  730.         $dir = uri_escape($dir, ':');
  731.     $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32;
  732.     $url = newlocal URI::URL '0';
  733.     $url->_expect('as_string', "file:$ss${dir}0");
  734.     }
  735.  
  736.     # Test access methods for file URLs
  737.     $url = new URI::URL 'file:/c:/dos';
  738.     $url->_expect('dos_path', 'C:\\DOS');
  739.     $url->_expect('unix_path', '/c:/dos');
  740.     #$url->_expect('vms_path', '[C:]DOS');
  741.     $url->_expect('mac_path',  'UNDEF');
  742.  
  743.     $url = new URI::URL 'file:/foo/bar';
  744.     $url->_expect('unix_path', '/foo/bar');
  745.     $url->_expect('mac_path', 'foo:bar');
  746.  
  747.     # Some edge cases
  748. #    $url = new URI::URL 'file:';
  749. #    $url->_expect('unix_path', '/');
  750.     $url = new URI::URL 'file:/';
  751.     $url->_expect('unix_path', '/');
  752.     $url = new URI::URL 'file:.';
  753.     $url->_expect('unix_path', '.');
  754.     $url = new URI::URL 'file:./foo';
  755.     $url->_expect('unix_path', './foo');
  756.     $url = new URI::URL 'file:0';
  757.     $url->_expect('unix_path', '0');
  758.     $url = new URI::URL 'file:../../foo';
  759.     $url->_expect('unix_path', '../../foo');
  760.     $url = new URI::URL 'file:foo/../bar';
  761.     $url->_expect('unix_path', 'foo/../bar');
  762.  
  763.     # Relative files
  764.     $url = new URI::URL 'file:foo/b%61r/Note.txt';
  765.     $url->_expect('unix_path', 'foo/bar/Note.txt');
  766.     $url->_expect('mac_path', ':foo:bar:Note.txt');
  767.     $url->_expect('dos_path', 'FOO\\BAR\\NOTE.TXT');
  768.     #$url->_expect('vms_path', '[.FOO.BAR]NOTE.TXT');
  769.  
  770.     # The VMS path found in RFC 1738 (section 3.10)
  771.     $url = new URI::URL 'file://vms.host.edu/disk$user/my/notes/note12345.txt';
  772. #    $url->_expect('vms_path', 'DISK$USER:[MY.NOTES]NOTE12345.TXT');
  773. #    $url->_expect('mac_path', 'disk$user:my:notes:note12345.txt');
  774.  
  775.     chdir($savedir) or die $!;
  776. }
  777.  
  778.  
  779. #####################################################################
  780. #
  781. # absolute_test()
  782. #
  783. sub absolute_test {
  784.  
  785.     print "Test relative/absolute URI::URL parsing:\n";
  786.  
  787.     # Tests from draft-ietf-uri-relative-url-06.txt
  788.     # Copied verbatim from the draft, parsed below
  789.  
  790.     @URI::URL::g::ISA = qw(URI::URL::_generic); # for these tests
  791.  
  792.     my $base = 'http://a/b/c/d;p?q#f';
  793.  
  794.     $absolute_tests = <<EOM;
  795. 5.1.  Normal Examples
  796.  
  797.       g:h        = <URL:g:h>
  798.       g          = <URL:http://a/b/c/g>
  799.       ./g        = <URL:http://a/b/c/g>
  800.       g/         = <URL:http://a/b/c/g/>
  801.       /g         = <URL:http://a/g>
  802.       //g        = <URL:http://g>
  803. #      ?y         = <URL:http://a/b/c/d;p?y>
  804.       g?y        = <URL:http://a/b/c/g?y>
  805.       g?y/./x    = <URL:http://a/b/c/g?y/./x>
  806.       #s         = <URL:http://a/b/c/d;p?q#s>
  807.       g#s        = <URL:http://a/b/c/g#s>
  808.       g#s/./x    = <URL:http://a/b/c/g#s/./x>
  809.       g?y#s      = <URL:http://a/b/c/g?y#s>
  810.  #     ;x         = <URL:http://a/b/c/d;x>
  811.       g;x        = <URL:http://a/b/c/g;x>
  812.       g;x?y#s    = <URL:http://a/b/c/g;x?y#s>
  813.       .          = <URL:http://a/b/c/>
  814.       ./         = <URL:http://a/b/c/>
  815.       ..         = <URL:http://a/b/>
  816.       ../        = <URL:http://a/b/>
  817.       ../g       = <URL:http://a/b/g>
  818.       ../..      = <URL:http://a/>
  819.       ../../     = <URL:http://a/>
  820.       ../../g    = <URL:http://a/g>
  821.  
  822. 5.2.  Abnormal Examples
  823.  
  824.    Although the following abnormal examples are unlikely to occur
  825.    in normal practice, all URL parsers should be capable of resolving
  826.    them consistently.  Each example uses the same base as above.
  827.  
  828.    An empty reference resolves to the complete base URL:
  829.  
  830.       <>         = <URL:http://a/b/c/d;p?q#f>
  831.  
  832.    Parsers must be careful in handling the case where there are more
  833.    relative path ".." segments than there are hierarchical levels in
  834.    the base URL's path.  Note that the ".." syntax cannot be used to
  835.    change the <net_loc> of a URL.
  836.  
  837.      ../../../g = <URL:http://a/../g>
  838.      ../../../../g = <URL:http://a/../../g>
  839.  
  840.    Similarly, parsers must avoid treating "." and ".." as special
  841.    when they are not complete components of a relative path.
  842.  
  843.       /./g       = <URL:http://a/./g>
  844.       /../g      = <URL:http://a/../g>
  845.       g.         = <URL:http://a/b/c/g.>
  846.       .g         = <URL:http://a/b/c/.g>
  847.       g..        = <URL:http://a/b/c/g..>
  848.       ..g        = <URL:http://a/b/c/..g>
  849.  
  850.    Less likely are cases where the relative URL uses unnecessary or
  851.    nonsensical forms of the "." and ".." complete path segments.
  852.  
  853.       ./../g     = <URL:http://a/b/g>
  854.       ./g/.      = <URL:http://a/b/c/g/>
  855.       g/./h      = <URL:http://a/b/c/g/h>
  856.       g/../h     = <URL:http://a/b/c/h>
  857.  
  858.    Finally, some older parsers allow the scheme name to be present in
  859.    a relative URL if it is the same as the base URL scheme.  This is
  860.    considered to be a loophole in prior specifications of partial
  861.    URLs [1] and should be avoided by future parsers.
  862.  
  863.       http:g     = <URL:http:g>
  864.       http:      = <URL:http:>
  865. EOM
  866.     # convert text to list like
  867.     # @absolute_tests = ( ['g:h' => 'g:h'], ...)
  868.  
  869.     for $line (split("\n", $absolute_tests)) {
  870.     next unless $line =~ /^\s{6}/;
  871.     if ($line =~ /^\s+(\S+)\s*=\s*<URL:([^>]*)>/) {
  872.         my($rel, $abs) = ($1, $2);
  873.         $rel = '' if $rel eq '<>';
  874.         push(@absolute_tests, [$rel, $abs]);
  875.     }
  876.     else {
  877.         warn "illegal line '$line'";
  878.     }
  879.     }
  880.  
  881.     # add some extra ones for good measure
  882.  
  883.     push(@absolute_tests, ['x/y//../z' => 'http://a/b/c/x/y/z'],
  884.               ['1'         => 'http://a/b/c/1'    ],
  885.               ['0'         => 'http://a/b/c/0'    ],
  886.               ['/0'        => 'http://a/0'        ],
  887. #              ['%2e/a'     => 'http://a/b/c/%2e/a'],  # %2e is '.'
  888. #              ['%2e%2e/a'  => 'http://a/b/c/%2e%2e/a'],
  889.     );
  890.  
  891.     print "  Relative    +  Base  =>  Expected Absolute URL\n";
  892.     print "================================================\n";
  893.     for $test (@absolute_tests) {
  894.     my($rel, $abs) = @$test;
  895.     my $abs_url = new URI::URL $abs;
  896.     my $abs_str = $abs_url->as_string;
  897.  
  898.     printf("  %-10s  +  $base  =>  %s\n", $rel, $abs);
  899.     my $u   = new URI::URL $rel, $base;
  900.     my $got = $u->abs;
  901.     $got->_expect('as_string', $abs_str);
  902.     }
  903.  
  904.     # bug found and fixed in 1.9 by "J.E. Fritz" <FRITZ@gems.vcu.edu>
  905.     $base = new URI::URL 'http://host/directory/file';
  906.     my $relative = new URI::URL 'file', $base;
  907.     my $result = $relative->abs;
  908.  
  909.     my ($a, $b) = ($base->path, $result->path);
  910.     die "'$a' and '$b' should be the same" unless $a eq $b;
  911.  
  912.     # Counter the expectation of least surprise,
  913.     # section 6 of the draft says the URL should
  914.     # be canonicalised, rather than making a simple
  915.     # substitution of the last component.
  916.     # Better doublecheck someone hasn't "fixed this bug" :-)
  917.     $base = new URI::URL 'http://host/dir1/../dir2/file';
  918.     $relative = new URI::URL 'file', $base;
  919.     $result = $relative->abs;
  920.     die 'URL not canonicalised' unless $result eq 'http://host/dir2/file';
  921.  
  922.     print "--------\n";
  923.     # Test various other kinds of URLs and how they like to be absolutized
  924.     for (["http://abc/", "news:45664545", "http://abc/"],
  925.      ["news:abc",    "http://abc/",   "news:abc"],
  926.      ["abc",         "file:/test?aas", "file:/abc"],
  927. #     ["gopher:",     "",               "gopher:"],
  928. #     ["?foo",        "http://abc/a",   "http://abc/a?foo"],
  929.      ["?foo",        "file:/abc",      "file:/?foo"],
  930.      ["#foo",        "http://abc/a",   "http://abc/a#foo"],
  931.      ["#foo",        "file:a",         "file:a#foo"],
  932.      ["#foo",        "file:/a",         "file:/a#foo"],
  933.      ["#foo",        "file:/a",         "file:/a#foo"],
  934.      ["#foo",        "file://localhost/a", "file://localhost/a#foo"],
  935.      ['123@sn.no',   "news:comp.lang.perl.misc", 'news:/123@sn.no'],
  936.      ['no.perl',     'news:123@sn.no',           'news:/no.perl'],
  937.      ['mailto:aas@a.sn.no', "http://www.sn.no/", 'mailto:aas@a.sn.no'],
  938.  
  939.      # Test absolutizing with old behaviour.
  940.      ['http:foo',     'http://h/a/b',   'http://h/a/foo'],
  941.      ['http:/foo',    'http://h/a/b',   'http://h/foo'],
  942.      ['http:?foo',    'http://h/a/b',   'http://h/a/?foo'],
  943.      ['http:#foo',    'http://h/a/b',   'http://h/a/b#foo'],
  944.      ['http:?foo#bar','http://h/a/b',   'http://h/a/?foo#bar'],
  945.      ['file:/foo',    'http://h/a/b',   'file:/foo'],
  946.  
  947.     )
  948.     {
  949.     my($url, $base, $expected_abs) = @$_;
  950.     my $rel = new URI::URL $url, $base;
  951.     my $abs = $rel->abs($base, 1);
  952.     printf("  %-12s+  $base  =>  %s\n", $rel, $abs);
  953.     $abs->_expect('as_string', $expected_abs);
  954.     }
  955.     print "absolute test ok\n";
  956.  
  957.     # Test relative function
  958.     for (
  959.      ["http://abc/a",   "http://abc",        "a"],
  960.      ["http://abc/a",   "http://abc/b",      "a"],
  961.      ["http://abc/a?q", "http://abc/b",      "a?q"],
  962.      ["http://abc/a;p", "http://abc/b",      "a;p"],
  963.      ["http://abc/a",   "http://abc/a/b/c/", "../../../a"],
  964.          ["http://abc/a/",  "http://abc/a/",     "./"],
  965.          ["http://abc/a#f", "http://abc/a",      "#f"],
  966.  
  967.      ["file:/etc/motd", "file:/",            "etc/motd"],
  968.      ["file:/etc/motd", "file:/etc/passwd",  "motd"],
  969.      ["file:/etc/motd", "file:/etc/rc2.d/",  "../motd"],
  970.      ["file:/etc/motd", "file:/usr/lib/doc", "../../etc/motd"],
  971.          ["file:",          "file:/etc/",        "../"],
  972.          ["file:foo",       "file:/etc/",        "../foo"],
  973.  
  974.      ["mailto:aas",     "http://abc",        "mailto:aas"],
  975.  
  976.      # Nicolai Langfeldt's original example
  977.      ["http://www.math.uio.no/doc/mail/top.html",
  978.       "http://www.math.uio.no/doc/linux/", "../mail/top.html"],
  979.         )
  980.     {
  981.     my($abs, $base, $expect) = @$_;
  982.     printf "url('$abs', '$base')->rel eq '$expect'\n";
  983.     my $rel = URI::URL->new($abs, $base)->rel;
  984.     $rel->_expect('as_string', $expect);
  985.     }
  986.     print "relative test ok\n";
  987. }
  988.  
  989.  
  990. sub eq_test
  991. {
  992.     my $u1 = new URI::URL 'http://abc.com:80/~smith/home.html';
  993.     my $u2 = new URI::URL 'http://ABC.com/%7Esmith/home.html';
  994.     my $u3 = new URI::URL 'http://ABC.com:/%7esmith/home.html';
  995.  
  996.     # Test all permutations of these tree
  997.     $u1->eq($u2) or die "1: $u1 ne $u2";
  998.     $u1->eq($u3) or die "2: $u1 ne $u3";
  999.     $u2->eq($u1) or die "3: $u2 ne $u1";
  1000.     $u2->eq($u3) or die "4: $u2 ne $u3";
  1001.     $u3->eq($u1) or die "5: $u3 ne $u1";
  1002.     $u3->eq($u2) or die "6: $u3 ne $u2";
  1003.  
  1004.     # Test empty path
  1005.     my $u4 = new URI::URL 'http://www.sn.no';
  1006.     $u4->eq("HTTP://WWW.SN.NO:80/") or die "7: $u4";
  1007.     $u4->eq("http://www.sn.no:81") and die "8: $u4";
  1008.  
  1009.     # Test mailto
  1010. #    my $u5 = new URI::URL 'mailto:AAS@SN.no';
  1011. #    $u5->eq('mailto:aas@sn.no') or die "9: $u5";
  1012.  
  1013.     # Test reserved char
  1014.     my $u6 = new URI::URL 'ftp://ftp/%2Fetc';
  1015.     $u6->eq("ftp://ftp/%2fetc") or die "10: $u6";
  1016.     $u6->eq("ftp://ftp://etc") and die "11: $u6";
  1017. }
  1018.  
  1019.